home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 2 / Tech Arsenal 2 (Arsenal Computer).iso / clipper / s93bsp.exe / CL5 / QBIPROC.PRG < prev    next >
Encoding:
Text File  |  1993-11-26  |  10.8 KB  |  468 lines
  1. ///////////////////////////////////////////////////////////////
  2. //
  3. //  Module : QBIPROC.PRG
  4. //
  5. //  Created by SUMMER'93 (c) on Fri Nov 26 14:50:20 1993
  6. //
  7. ///////////////////////////////////////////////////////////////
  8. #include "snj.ch"
  9. // The following statics were declared 'PUBLIC' in the S87 code
  10. // OR were private and inherited by called functions
  11. // If they are used outside this module there will be a set/get
  12. // function with the same name as the var in this module
  13. static QBSAFE, QBTITLE, QBMSGLIN, QBPROC, COLNORM, COLPWD, COLFLASH, COLHEAD;
  14. , COLMENU, COLBRIGHT, COLMON, QBVAT, GETOUT, CHANGED, QBKEY, QBCHOICE, QBDATE;
  15. , QBRESP, QBRESPD, PLENGTH, PLINE, PHEAD1, PHEAD2, PHEAD3, PHEAD4, PHEAD5;
  16. , PHEAD6, PHEAD7, PHEAD8, PHEAD9, PFOOT1, PFOOT2, PFOOT3, PFOOT4, PFOOT5;
  17. , PWIDTH, PSET1, PSET2, PSET3, PSET4, PSET5, TPSET1, TPSET2
  18. procedure QBINIT
  19. // Calls: QBINDATE QBLAYOUT QBBOX 
  20. // Called By: BODINDEX BODYWORK 
  21. //                   Q B I N I T . P R G
  22. // The following locals have been declared by Summer'93
  23. // MEM 
  24. local m, MEM
  25. clear screen
  26. set date british 
  27. set exact off 
  28. set talk off 
  29. set safety off 
  30. set unique off 
  31. set bell off 
  32. set wrap on 
  33. set scoreboard off 
  34. set deleted on 
  35. set status off 
  36. set device to screen 
  37. set intensity on 
  38. set function 9 to chr( 23 )
  39. //    Last change:  MIB  11 Aug 93    4:44 pm
  40.  
  41.  
  42.  
  43. //       Print intialisation
  44. PDEST( " "  )
  45. PHEAD1 := PHEAD2 := PHEAD3 := PHEAD4 := PHEAD5 := PHEAD6 := PHEAD7 := ;
  46. PHEAD8 := PHEAD9 := "" 
  47.  
  48. use QBINFO index QBINFO 
  49. seek "COLOUR" 
  50. COLMON := ( trim(FIELD->QBTEXT ) = "C" )
  51. seek "PSET1" 
  52. MEM := trim( FIELD->QBTEXT )
  53. PSET1 := &MEM  // set system emulation mode
  54. skip 
  55. MEM := trim( FIELD->QBTEXT )
  56. PSET5 := PSET1 + &MEM  // Set  normal text
  57. skip 
  58. MEM := trim( FIELD->QBTEXT )
  59. PSET4 := PSET1 + &MEM  // Set compressed
  60. skip 
  61. MEM := trim( FIELD->QBTEXT )
  62. PSET2 := PSET4 + &MEM  // Set compressed portrait
  63. PSET5 := PSET5 + &MEM  // Set normal portrait
  64. skip 
  65. MEM := trim( FIELD->QBTEXT )
  66. PSET3 := PSET4 + &MEM  // Set compressed landscape
  67. TPSET1 := PSET2 
  68. TPSET2 := PSET5 
  69.  
  70. GETOUT := .f. 
  71. CHANGED := .f. 
  72. QBKEY := 0  // Keystroke returned from qbmenu
  73. QBCHOICE := 1 
  74.  
  75. QBTITLE := space( 30 ) // Application title - qbinfo record #1
  76. if COLMON 
  77.     COLNORM := "W/B,N/W,B,B,W+/B"  // Normal screen colours
  78.     COLBRIGHT := "W+/B,N/W+,B,B,W+/B"  // Say data high
  79.     COLMENU := "W+/B,N/W+,B,B,W+/B" 
  80.     COLPWD := "W+/B,B/B,B,B"  // Password screen colours
  81.     COLFLASH := "R*/W,N*/W,B,B"  // Flashing message
  82.     COLHEAD := "GR+/B,N/W,B,B,W+/B"  // Bright Yellow/Blue
  83. else 
  84.     COLNORM := "W/N,N/W,,,W+/N" 
  85.     COLBRIGHT := "W+/N,N/W+,,,W+/N"  // Say data high
  86.     COLMENU := "W+/N,N/W+" 
  87.     COLPWD := "N/N,N/N,X" 
  88.     COLFLASH := "W*/N,N/W*" 
  89.     COLHEAD := "N/W+,W/N,,,W+/N" 
  90. endif 
  91. QBPROC := space( 30 ) // Procedure name being run
  92. QBMSGLIN := 0 
  93. QBRESP := " " 
  94. do QBINDATE
  95.  
  96. // Get password
  97. do QBLAYOUT with "Password Verification" 
  98. do QBBOX with 40 
  99. set color to( iif(COLMON, COLHEAD, COLBRIGHT ))
  100. m := "Quin Butterworth Spangenthal" 
  101. @ 9, centre( m )say m 
  102. m := "Systems Design & Consultancy" 
  103. @ 12, centre( m )say m 
  104. m := "for support call" 
  105. @ 14, centre( m )say m 
  106. m := "081-994-4842" 
  107. @ 16, centre( m )say m 
  108. set color to( COLNORM )
  109. close database 
  110.  
  111. set color to( COLNORM )
  112.  
  113. set exact off 
  114. select 0 
  115. use QBINFO index QBINFO 
  116. seek "HEADING" 
  117. if found( )
  118.     QBTITLE := trim( FIELD->qbtext )
  119. else 
  120.     QBTITLE := "Quin Butterworth Spangenthal" 
  121. endif 
  122. seek "VATRATE" 
  123. if !eof( )
  124.     QBVAT := val( FIELD->qbtext )
  125. else 
  126.     QBVAT := 17.50 
  127. endif 
  128.  
  129. return 
  130.  
  131. procedure QBINDATE
  132. // Calls: QBLAYOUT QBMESS QBLSTSUN QBGETD 
  133. // Called By: QBINIT 
  134.  
  135. //   Q B I N D A T E . P R G
  136. // Check the system date and get the user to confirm it or change
  137. // The following locals have been declared by Summer'93
  138. // D 
  139. local T, THE_DATE, D
  140.  
  141. QBDATE := space( 29 )
  142. // Time bomb could go in here
  143. // data record contains date last used, date to blow up
  144. // if date < date last used error reenter else if
  145. // if date> timebomb date blow up
  146.  
  147. do QBLAYOUT with "Q B Systems" 
  148. do QBMESS with "Checking Date", COLFLASH, 0 
  149. do QBLSTSUN
  150.  
  151. THE_DATE := date( )
  152.  
  153. do while THE_DATE  = ctod( "01/01/80" )
  154.     do QBGETD with "Input today's date", "01/01/80" 
  155.     QBDATE := dtoc( QBRESPD )
  156.     run date  ( QBDATE ) 
  157.     THE_DATE := date( )
  158. enddo 
  159.  
  160. D := day( THE_DATE )
  161. do case 
  162.     case D  = 1 .or. D  = 21 .or. D  = 31 
  163.         T := "st" 
  164.     case D  = 2 .or. D  = 22 
  165.         T := "nd" 
  166.     case D  = 3 .or. D  = 23 
  167.         T := "rd" 
  168.     otherwise 
  169.         T := "th" 
  170. endcase 
  171.  
  172. QBDATE := cdow( THE_DATE ) + " " + str( day(THE_DATE ), 2 ) + T + " "  + ;
  173. cmonth( THE_DATE ) + " " + str( year(THE_DATE ), 4 )
  174.  
  175. return 
  176.  
  177. procedure QBPSETUP
  178. // Calls: QBPROMPT 
  179. // Called By: BODINDEX 
  180.  
  181. // The following locals have been declared by Summer'93
  182. // MPSET1 MPSET2 MPSET3 MPSET4 MPSET5 I 
  183. local GETLIST, MPSET1, MPSET2, MPSET3, MPSET4, MPSET5, I
  184. GETLIST := {}
  185. clear screen
  186. @ 1, 0 to 1, 79 double 
  187. @ 2, 0 say "Q.B. Systems Ltd." 
  188. @ 3, 0 to 3, 79 double 
  189. @ 21, 0 to 21, 79 double 
  190. @ 2, 32 say "Printer Setup" 
  191. use QBINFO index QBINFO 
  192. do while .t. 
  193.     seek "PSET1" 
  194.     MPSET1 := FIELD->QBTEXT 
  195.     skip 
  196.     MPSET2 := FIELD->QBTEXT 
  197.     skip 
  198.     MPSET3 := FIELD->QBTEXT 
  199.     skip 
  200.     MPSET4 := FIELD->QBTEXT 
  201.     skip 
  202.     MPSET5 := FIELD->QBTEXT 
  203.     seek "PSET1" 
  204.     do while .t. 
  205.         @ 6, 5 say ;
  206.         "Unprintable Decimal ASCII codes should appear as CHR(n) functions" 
  207.         @ 7, 5 say "i.e. Escape is chr(27)" 
  208.         @ 8, 5 say "Printable ASCII codes should appear in single quotes" 
  209.         @ 9, 5 say "i.e. 'ABC'" 
  210.         @ 10, 5 say ;
  211.         "Strings of control codes should be concatenated with '+'" 
  212.         @ 11, 5 say "i.e. chr(27)+'15'" 
  213.         @ 13, 10 say "Printer initialisation " get MPSET1 
  214.         @ 14, 10 say "Normal Characters      " get MPSET2 
  215.         @ 15, 10 say "Compressed print       " get MPSET3 
  216.         @ 16, 10 say "Portrait               " get MPSET4 
  217.         @ 17, 10 say "Landscape              " get MPSET5 
  218.         read 
  219.         if ["] $ MPSET1 + MPSET2 + MPSET3 + MPSET4 + MPSET5 
  220.             @ 22, 2 say ;
  221.             [There is a " in a print setup string! Please use ' instead. Press a key.] 
  222.             wait " " 
  223.             @ 22, 0 clear 
  224.         else 
  225.             I := QBPROMPT( "Save|Edit|Quit|Restart", "", 1 )
  226.             do case 
  227.                 case QBRESP  = "Q" 
  228.                     use 
  229.                     return 
  230.                 case QBRESP  = "R" 
  231.                     exit 
  232.                 case QBRESP  = "S" 
  233.                     replace  FIELD->QBTEXT with MPSET1 
  234.                     skip 
  235.                     replace  FIELD->QBTEXT with MPSET2 
  236.                     skip 
  237.                     replace  FIELD->QBTEXT with MPSET3 
  238.                     skip 
  239.                     replace  FIELD->QBTEXT with MPSET4 
  240.                     skip 
  241.                     replace  FIELD->QBTEXT with MPSET5 
  242.                     use 
  243.                     return 
  244.             endcase 
  245.         endif 
  246.     enddo 
  247. enddo 
  248.  
  249. return 
  250.  
  251. FUNCTION QBTITLE( xNewVal )
  252. local xReturn := QBTITLE
  253. if xNewVal <> NIL
  254.     QBTITLE := xNewVal
  255. endif
  256. return xReturn
  257.  
  258. FUNCTION QBMSGLIN( xNewVal )
  259. local xReturn := QBMSGLIN
  260. if xNewVal <> NIL
  261.     QBMSGLIN := xNewVal
  262. endif
  263. return xReturn
  264.  
  265. FUNCTION QBPROC( xNewVal )
  266. local xReturn := QBPROC
  267. if xNewVal <> NIL
  268.     QBPROC := xNewVal
  269. endif
  270. return xReturn
  271.  
  272. FUNCTION COLNORM( xNewVal )
  273. local xReturn := COLNORM
  274. if xNewVal <> NIL
  275.     COLNORM := xNewVal
  276. endif
  277. return xReturn
  278.  
  279. FUNCTION COLPWD( xNewVal )
  280. local xReturn := COLPWD
  281. if xNewVal <> NIL
  282.     COLPWD := xNewVal
  283. endif
  284. return xReturn
  285.  
  286. FUNCTION COLFLASH( xNewVal )
  287. local xReturn := COLFLASH
  288. if xNewVal <> NIL
  289.     COLFLASH := xNewVal
  290. endif
  291. return xReturn
  292.  
  293. FUNCTION COLHEAD( xNewVal )
  294. local xReturn := COLHEAD
  295. if xNewVal <> NIL
  296.     COLHEAD := xNewVal
  297. endif
  298. return xReturn
  299.  
  300. FUNCTION COLMENU( xNewVal )
  301. local xReturn := COLMENU
  302. if xNewVal <> NIL
  303.     COLMENU := xNewVal
  304. endif
  305. return xReturn
  306.  
  307. FUNCTION COLBRIGHT( xNewVal )
  308. local xReturn := COLBRIGHT
  309. if xNewVal <> NIL
  310.     COLBRIGHT := xNewVal
  311. endif
  312. return xReturn
  313.  
  314. FUNCTION QBVAT( xNewVal )
  315. local xReturn := QBVAT
  316. if xNewVal <> NIL
  317.     QBVAT := xNewVal
  318. endif
  319. return xReturn
  320.  
  321. FUNCTION GETOUT( xNewVal )
  322. local xReturn := GETOUT
  323. if xNewVal <> NIL
  324.     GETOUT := xNewVal
  325. endif
  326. return xReturn
  327.  
  328. FUNCTION CHANGED( xNewVal )
  329. local xReturn := CHANGED
  330. if xNewVal <> NIL
  331.     CHANGED := xNewVal
  332. endif
  333. return xReturn
  334.  
  335. FUNCTION QBKEY( xNewVal )
  336. local xReturn := QBKEY
  337. if xNewVal <> NIL
  338.     QBKEY := xNewVal
  339. endif
  340. return xReturn
  341.  
  342. FUNCTION QBCHOICE( xNewVal )
  343. local xReturn := QBCHOICE
  344. if xNewVal <> NIL
  345.     QBCHOICE := xNewVal
  346. endif
  347. return xReturn
  348.  
  349. FUNCTION QBDATE( xNewVal )
  350. local xReturn := QBDATE
  351. if xNewVal <> NIL
  352.     QBDATE := xNewVal
  353. endif
  354. return xReturn
  355.  
  356. FUNCTION QBRESP( xNewVal )
  357. local xReturn := QBRESP
  358. if xNewVal <> NIL
  359.     QBRESP := xNewVal
  360. endif
  361. return xReturn
  362.  
  363. FUNCTION QBRESPD( xNewVal )
  364. local xReturn := QBRESPD
  365. if xNewVal <> NIL
  366.     QBRESPD := xNewVal
  367. endif
  368. return xReturn
  369.  
  370. FUNCTION PLENGTH( xNewVal )
  371. local xReturn := PLENGTH
  372. if xNewVal <> NIL
  373.     PLENGTH := xNewVal
  374. endif
  375. return xReturn
  376.  
  377. FUNCTION PLINE( xNewVal )
  378. local xReturn := PLINE
  379. if xNewVal <> NIL
  380.     PLINE := xNewVal
  381. endif
  382. return xReturn
  383.  
  384. FUNCTION PHEAD1( xNewVal )
  385. local xReturn := PHEAD1
  386. if xNewVal <> NIL
  387.     PHEAD1 := xNewVal
  388. endif
  389. return xReturn
  390.  
  391. FUNCTION PHEAD2( xNewVal )
  392. local xReturn := PHEAD2
  393. if xNewVal <> NIL
  394.     PHEAD2 := xNewVal
  395. endif
  396. return xReturn
  397.  
  398. FUNCTION PHEAD3( xNewVal )
  399. local xReturn := PHEAD3
  400. if xNewVal <> NIL
  401.     PHEAD3 := xNewVal
  402. endif
  403. return xReturn
  404.  
  405. FUNCTION PHEAD4( xNewVal )
  406. local xReturn := PHEAD4
  407. if xNewVal <> NIL
  408.     PHEAD4 := xNewVal
  409. endif
  410. return xReturn
  411.  
  412. FUNCTION PHEAD5( xNewVal )
  413. local xReturn := PHEAD5
  414. if xNewVal <> NIL
  415.     PHEAD5 := xNewVal
  416. endif
  417. return xReturn
  418.  
  419. FUNCTION PHEAD6( xNewVal )
  420. local xReturn := PHEAD6
  421. if xNewVal <> NIL
  422.     PHEAD6 := xNewVal
  423. endif
  424. return xReturn
  425.  
  426. FUNCTION PHEAD7( xNewVal )
  427. local xReturn := PHEAD7
  428. if xNewVal <> NIL
  429.     PHEAD7 := xNewVal
  430. endif
  431. return xReturn
  432.  
  433. FUNCTION PHEAD8( xNewVal )
  434. local xReturn := PHEAD8
  435. if xNewVal <> NIL
  436.     PHEAD8 := xNewVal
  437. endif
  438. return xReturn
  439.  
  440. FUNCTION PHEAD9( xNewVal )
  441. local xReturn := PHEAD9
  442. if xNewVal <> NIL
  443.     PHEAD9 := xNewVal
  444. endif
  445. return xReturn
  446.  
  447. FUNCTION PWIDTH( xNewVal )
  448. local xReturn := PWIDTH
  449. if xNewVal <> NIL
  450.     PWIDTH := xNewVal
  451. endif
  452. return xReturn
  453.  
  454. FUNCTION PSET2( xNewVal )
  455. local xReturn := PSET2
  456. if xNewVal <> NIL
  457.     PSET2 := xNewVal
  458. endif
  459. return xReturn
  460.  
  461. FUNCTION TPSET1( xNewVal )
  462. local xReturn := TPSET1
  463. if xNewVal <> NIL
  464.     TPSET1 := xNewVal
  465. endif
  466. return xReturn
  467. // End of file
  468.